home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / CAD / LISP04.ARJ / MULTRIM.LSP < prev    next >
Text File  |  1989-10-20  |  4KB  |  121 lines
  1. ; program: MULTIPLETRIM COMMAND - MULTRIM.LSP
  2. ;
  3. ; description: Trims with selection of many items to trim
  4. ;              actual selection is by crossing, and items
  5. ;              must cross a line between the selected crossing
  6. ;              points.  No allowance is made for removal of
  7. ;              items from the selection set.
  8. ;
  9. ;
  10. ; variables used and their description:
  11. ;cs       selection set containing cutting edges
  12. ;p1       first point for crossing selection (for ts)
  13. ;p2       second point for crossing selection (for ts)
  14. ;ts       election set containing items to be trimmed
  15. ;ic       item count through trim set (ts)
  16. ;te       entity name from ts to trim
  17. ;ge       entity list of te
  18. ;et       entity type of te
  19. ;cp       center point of arc or circle
  20. ;ra       radius of arc or circle
  21. ;sa       start angle of arc or circle (arbitrarily 0 for circle)
  22. ;ea       end angle of arc or circle (arbitrarily 2pi for circle)
  23. ;dv       divisor for number of segments to increment arcs
  24. ;ma       intermediate angle of arc increment
  25. ;ia       increment angle for arcs (approximately 10-degrees)
  26. ;p3       first point on entity to check for an intersection
  27. ;p4       second intersection check point (used with arcs and polylines)
  28. ;tp       trim point on entity to trim
  29. ;e3       vertex of polyline used to get p3
  30. ;e4       vertex of polyline used to get p4
  31. ;d1,d2,p3 intermediate variables to determine tp on circles
  32. ;
  33. ;
  34. (defun c:multrim (/ cs p1 p2 ts ic te ge et cp ra sa ea dv ma ia p3 p4 tp e3 e4 d1 d2)
  35. (setvar "CMDECHO" 0)
  36. (princ "\nSelect cutting edges: ")
  37. (setq cs (ssget))
  38. (princ "Select objects to cut: ")
  39. (setq p1 (getpoint "Select first point: ")
  40.   p2 (getpoint p1 "Select other point: ")
  41.   ts (ssget "c" p1 p2)
  42.   ic 0
  43. )
  44. (grdraw p1 p2 -1 1)
  45. (while (setq te (ssname ts ic))
  46.   (if (ssmemb te cs)
  47.            (setq et nil)
  48.            (setq ge (entget te)
  49.               et (cdr (assoc 0 ge))
  50.          )
  51. )
  52. (cond
  53.   ((= et "ARC")
  54.            (setq cp (cdr (assoc 10 ge))
  55.               ra (cdr (assoc 40 ge))
  56.               sa (cdr (assoc 50 ge))
  57.               ea (cdr (assoc 51 ge))
  58.            )
  59.            (if (> sa ea)
  60.              (setq ea (+ ea pi pi))
  61.            )
  62.            (if (> 2 (setq dv (fix (/ (- ea sa) (/ pi 18))) ))
  63.                 (setq dv 2)
  64.            )
  65.            (setq ma sa
  66.                 ia (/ (- ea sa) dv)
  67.                 p4 (polar cp sa ra)
  68. )
  69. (while (< ma ea)
  70.    (setq p3 p4
  71.       p4 (polar cp (setq ma (+ ma ia)) ra)
  72.    )
  73.         (if (setq tp (inters p1 p2 p3 p4))
  74.            (command "TRIM" cs "" (list te tp) "")
  75.         )
  76.     )
  77. )
  78. ((= et "CIRCLE")
  79.     (setq cp (cdr (assoc 10 ge))
  80.         ra (cdr (assoc 40 ge))
  81.         d1 (* (cos (- (angle p1 cp) (angle p1 p2))) (distance cp p1))
  82.         p3 (polar p1 (angle p1 p2) d1)
  83.         d2 (distance cp p3)
  84.         tp (polar p3 (angle p1 p2) (sqrt (- (* ra ra) (* d2 d2) )))
  85.     )
  86.     (command "TRIM" cs "" (list te tp) "")
  87. )
  88. ((= et "POLYLINE")
  89.    (setq e3 (entget (entnext te))
  90.       p3 (cdr (assoc 10 e3))
  91.    )
  92.    (while (/= "SEQEND" (cdr (assoc 0 (setq e4 (entget (entnext
  93.       (cdr (assoc -1 e3))) ))) ))
  94.       (setq p4 (cdr (assoc 10 e4)))
  95.       (if (setq tp (inters p1 p2 p3 p4))
  96.              (progn
  97.                 (command "TRIM" cs "" (list te tp) "")
  98.                 (setq e4 (entget (entnext (setq te (entlast) )))
  99.                     p4 (cdr (assoc 10 e4))
  100.                    )
  101.             )
  102.      )
  103.      (setq e3 e4
  104.         p3 p4
  105.      )
  106.    )
  107. )    
  108. ((= et "LINE")
  109.    (if (setq tp (inters (cdr (assoc 10 ge )) (cdr (assoc 11 ge)) p1 p2))
  110.       (command "TRIM" cs "" (list te tp) "")
  111.     )
  112.    )
  113.   )
  114.   (setq ic (1+ ic))
  115. )
  116. (grdraw p1 p2 -1 1)
  117. (setq cs nilp1 nilp2 nilts nilge nilic nilte nilet niltp
  118.       nilcp nilra nilsa nilea nildv nilma nilia nilp3
  119.       nilp4 nild1 nild2 nile3 nile4 nil
  120. )
  121. (princ))